home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / mgn.com / MGN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-04-14  |  12.7 KB  |  307 lines
  1. program MenuEngine;  {Yet Another Menu System by Ed Keefe, APRIL '89 }
  2. uses dos, crt;       {Public Domain Program: may be shared freely. 
  3.               No rights reserved.}
  4.  
  5. Const
  6.      maxitems = 9 ;     { maximum number of items per submenu less 1}
  7.      maxsubs  = 9 ;     { maximum number of submenus less 1}
  8.      normbackground   = brown ;     normforeground   = yellow;     
  9.      highbackground   = lightgray ; highforeground   = black;
  10.      {You may pick other colors if you like.}
  11.  
  12. type
  13.      st15 = string[15];  {a short string}
  14.  
  15.     itemtype = record  { Basic record structure for the menu.}
  16.        r,c  : byte;    { Where ...}
  17.        s    : st15;    { What ...}
  18.        t    : byte;    { type of menu: 0=exec;1,2,3..= #submenu }
  19.     end;
  20.  
  21.     submtype= record
  22.         num      : byte; {How many items in this submenu...}
  23.         mnuitem  : array [0..maxitems] of itemtype; { = 10 items}
  24.     end;
  25.  
  26.     mnutype = array[0..maxsubs] of submtype;        { = 10 submenus }
  27.  
  28. var
  29.      i,j,t, hcode,row,col,mcnt,subnum,ndx : byte;
  30.      mnuara : mnutype;    {--an array of records made up of a byte}
  31.      parm   : st15;       {and an array of records of bytes and strings }
  32.      code   : integer;
  33.      inf    : text;
  34.      ch     : char;
  35.      again  : boolean;
  36.      scr    : byte;
  37.      mode   : word;
  38.  
  39. function stupr(s:st15):st15;  {converts string to uppercase}
  40. var       i : byte;
  41. begin
  42.     for i := 1 to length(s) do s[i]:=upcase(s[i]);
  43.     stupr := s;
  44. end;
  45.  
  46. procedure cursoron;
  47. var
  48.     regs:registers;               {registers defined in dos unit}
  49. begin
  50.     if mode in[0..3] then
  51.        begin
  52.           regs.ah := $01;                { restore color cursor }
  53.           regs.ch := $06;
  54.           regs.cl := $07;
  55.           intr($10,regs);
  56.        end
  57.     else
  58.        if (mode = 7) then
  59.           begin
  60.              regs.ah := $01;            { restore mono cursor }
  61.              regs.ch := $c;
  62.              regs.cl := $d;
  63.              intr($10,regs);
  64.      end;
  65. end;
  66.  
  67. procedure cursoroff;
  68. var
  69.    regs:registers;
  70. begin                            { set bit 5 of cursor control byte }
  71.    regs.ah := $01;               { which turns cursor off           }
  72.    regs.ch := $20;
  73.    intr($10,regs);
  74. end;
  75.  
  76. procedure errmsg(n:byte);
  77. begin
  78.      case n of
  79.         0 : write('Please use 1 to 10 items per menu.');
  80.         1 : write('Parm 1 must be H or V');
  81.         2 : write('Parm 2 = row');
  82.         3 : write('Parm 3 = col');
  83.         4 : write(paramstr(1),' file not found.');
  84.         5 : write('USAGE: MGN  menufile.ext');
  85.      end;
  86.      cursoron;
  87.      halt(255);
  88. end;
  89.  
  90. procedure hvmnu(m:byte;horv:char); {Set up the record for horiz. or vert. menu}
  91. var  i, place :  byte;
  92. begin
  93.   mnuara[m].num := paramcount-4; {put the number of items in the num field
  94.                                  of the record}
  95.   place := 0;
  96.   for i := 0 to paramcount-4 do  {repeat for the number of items in the subm}
  97.     with mnuara[m].mnuitem[i] do {use the submenu[m] and the ith element from
  98.                                  the menuitem field of the record}
  99.      begin
  100.        if horv = 'H' then        { setup for horiz.menu structure}
  101.          begin
  102.             r:=row;
  103.             c:=col+place;
  104.             s:=' '+paramstr(i+4)+'  ';  {pad with blanks right and left}
  105.             place:= place+length(paramstr(i+4))+2;
  106.          end
  107.       else
  108.          begin                   {setup for vert. menu structure}
  109.             r:=row+place;
  110.             c:=col;
  111.             s:=' '+paramstr(i+4);
  112.             while length(s)<15 do s:=s+' '; {pad on the right with blanks}
  113.             place:= place+1;
  114.          end;
  115.       if pos('*',paramstr(i+4))<>0 then {compute submenu number: 1,2,3...}
  116.          begin                          {t:=0 by default with fillchar() }
  117.             subnum:=succ(subnum);       {Keep track of the submenus...}
  118.             t:=subnum;
  119.          end;
  120.      end;
  121. end;
  122.  
  123. procedure show_item(m,ndx,high:byte);   { turn lightbar on/off }
  124. begin
  125.      gotoxy(mnuara[m].mnuitem[ndx].c,mnuara[m].mnuitem[ndx].r);
  126.      if high = 0 then textattr := normforeground+normbackground*$10
  127.      else textattr := highforeground+highbackground*$10;
  128.      write(mnuara[m].mnuitem[ndx].s);
  129. end;
  130.  
  131. procedure disp_menu(m,ndx:byte);
  132. begin
  133.          textattr:=normforeground+normbackground*$10;
  134.          with mnuara[m] do                   { Display list }
  135.           For ndx:=0 to mnuara[m].num do { the number of items is contained
  136.                                           in the first field of the record}
  137.               with mnuara[m].mnuitem[ndx] do
  138.               begin
  139.                    gotoxy(c,r);
  140.                    write(s);
  141.               end;      { the submenu is now displayed. }
  142. end;
  143.  
  144. function domenu(m: byte):byte;  { show the menu;get choice;return value}
  145. Var  count : byte;
  146.      st : st15;
  147. Begin  { domenu }
  148.      disp_menu(m,ndx);
  149.      ndx:=0;
  150.      Repeat
  151.            show_item(m,ndx,1);                     { highlight the item }
  152.            ch := readkey; if ch = ^@ then ch:=readkey; {Fetch a scancode}
  153.            case ch of                              { make a choice }
  154.                 #13        :  if ndx=mnuara[m].num then domenu:=255
  155.                               else domenu := ndx+(m*10);
  156.                 #27        :  domenu := 255;
  157.                 #8,'K','H' :  begin show_item(m,ndx,0); {turn off the item}
  158.                               if ndx > 0 then ndx := ndx-1   {wraparound?}
  159.                               else ndx:=mnuara[m].num;  end;
  160.                 ' ','M','P':  begin  show_item(m,ndx,0);
  161.                               if ndx < mnuara[m].num then ndx:=ndx+1
  162.                               else ndx:=0; end;
  163.                 'G','I'    :  begin show_item(m,ndx,0); ndx :=0; end;
  164.                 'O','Q'    :  begin show_item(m,ndx,0);ndx :=
  165.                                                        mnuara[m].num; end;
  166.                 else                  { Check for second character of item }
  167.                               Begin
  168.                                  show_item(m,ndx,0); {turn off item}
  169.                                  count:=ndx;         {save ndx to count}
  170.                                  Repeat
  171.                                    count:=succ(count); {start here and look}
  172.                                    If count > mnuara[m].num {at all items in}
  173.                                    then count:=0;      {the submenu.}
  174.                                    st := mnuara[m].mnuitem[count].s;
  175.                                  Until (count = ndx) Or
  176.                                  (upcase(ch) = upcase(st[2]));
  177.                                  ndx:=count            {new or original ndx}
  178.                               End;
  179.            end; {case}
  180.          Until (ch = #13) Or (ch = #27);
  181. end;
  182.  
  183. Begin  { Main Program }
  184.        mode := lastmode;     {get current video mode}
  185.        directvideo:=true; {snappier response}
  186.        clrscr;           
  187.        scr := textattr;   {built-in text background and color}
  188.        cursoroff;
  189.        fillchar(mnuara, sizeof(mnuara),0); {zero-out the array}
  190.        if paramcount < 1 then errmsg(5);   {do some error trapping}
  191.        assign(inf,paramstr(1));
  192.        {$I-} reset(inf);{$I+}           {Is the menufile found?}
  193.        if IOResult<>0 then errmsg(4);
  194.        mcnt:=0; subnum:=0;
  195.        while( not eof(inf)) and ( mcnt < 10) do
  196.            begin
  197.                 readln(inf,string(ptr(prefixseg,$80)^)); {jam line into PSP}
  198.                 parm := stupr(paramstr(1));              {use paramstr/count}
  199.                 if not (parm[1] in ['H','V'])  then errmsg(1); {to parse.}
  200.                 val(paramstr(2),row,code);if code <> 0 then errmsg(2);
  201.                 val(paramstr(3),col,code);if code <> 0 then errmsg(3);
  202.                 if (paramcount < 4) and (paramcount>10) then errmsg(0);
  203.                 hvmnu (mcnt,parm[1] );                  {load a submenu}
  204.                 mcnt :=succ(mcnt);
  205.        end;    { we, now, have the mnuara loaded}
  206.        close(inf);
  207.        {Show main menu}
  208.        subnum:=0; again:=true;
  209.        repeat
  210.              if subnum=0 then
  211.              begin textattr:=scr ; clrscr; end;
  212.              hcode := domenu(subnum);
  213.              t := mnuara[subnum].mnuitem[ndx].t;
  214.              {SEE Footnote1 for the next line}
  215.          if((t<>0) and (hcode<>255)) or ((subnum<>0) and (hcode=255)) 
  216.          then subnum:=t
  217.              else again:=false;
  218.        until not again;
  219.        normvideo;
  220.        cursoron; 
  221.                  gotoxy(1,21); { <--- this is just for use with M.BAT}
  222.        halt(hcode);            { You may delete it from your version }
  223. End.
  224.  
  225. Footnote1:   At this point we have hcode,subnum, t: we want to determine);             if we should repeat or exit the loop on the basis of these 3
  226.              variables. What *should* happen is the following.
  227.              In the main menu, if I press ESC or Exit[Return], I should
  228.              quit the loop. Otherwise, if I press Return on a starred item,
  229.              I should get a submenu. On the other hand, if I press a non-
  230.              starred item, I should leave the loop with the value of hcode
  231.              as my errorlevel. (Leaving the loop with ESC or Exit generates
  232.              and  errorlevel of 255. )
  233.  
  234.              If I am in a submenu and I press ESC or Quit[Return], I should
  235.              return to the main menu. On the other hand, if I press Return
  236.              on a non-starred option, I should leave the loop with the val-
  237.              ue of hcode as my DOS errorlevel. Usually, submenu options will
  238.              not be starred. But, just in case, if I press Return on a star-
  239.              red item, I should get a further submenu. 
  240.  
  241.              So, with 3 variables, each of which have "either-or" type val-
  242.              ues, I know that I have 2^3=8 possible cases to consider. Here 
  243.              they are...
  244.  
  245.              SUBNUM      ACTION        STOP OR     AGAIN
  246.              (current    Desired        RETURN        Boolean
  247.              level of    t=0 -> exec    h=255;        value to
  248.              menuing)   t<>0 ->do a     h<>255;        control
  249.                       submenu                looping.
  250.               -------------------------------------------------
  251.         =0         =0        =255        false
  252.                 =0       =0        <>255        false
  253.                 =0       <>0        =255        false
  254.                 =0       <>0        <>255        true
  255.                 <>0       =0        =255        true
  256.                 <>0       =0        <>255        false
  257.                 <>0       <>0        =255        true
  258.                 <>0       <>0        <>255        true
  259.                 
  260.              Initially, AGAIN is TRUE. I want a short way to determine when
  261.              it will go FALSE.
  262.              
  263.              SO, I write...
  264.              
  265.              If ((subnum=0) and (t<>0) and (hcode<>255)) OR
  266.                 ((subnum<>0) and (t<>0) and (hcode<>255)) OR
  267.                 ((subnum<>0) and (t<>0) and (hcode=255)) OR
  268.                 ((subnum<>0) and (t<>0) and (hcode=255)) OR
  269.              Then AGAIN := TRUE
  270.              Else AGAIN := FALSE;
  271.              
  272.              Now, it's time to dig out the old Boolean Logic Book and
  273.              simplify this expression.
  274.              
  275.              Abbreviating: -X means X <> 0 or X <> 255
  276.                         * means the logical AND (&&)
  277.                         + means the logical OR (!!)
  278.              (S* -T * -H) + ( -S * -T * -H) + (-S * T * H) + (-S * -T * H)
  279.              factoring out common expressions...
  280.              (-T * -H) * (S + -S)           + (-S * H) *  (T + -T)
  281.                           always 1                         always 1
  282.              Skipping a couple of steps in logic, yields the following code..
  283.          if((t<>0) and (hcode<>255)) or ((subnum<>0) and (hcode=255)) 
  284.              *)
  285.  
  286.        And that's all he wrote...t'aint elegant, and not very sophisticated
  287.        but MenuEngine makes a great "batch file enhancer", I think. If you
  288.        want to get more elaborate, you can call the same program more than
  289.        once in the same batch file and have several menus on the screen at
  290.        the same time. 
  291.        
  292.        You could try rewriting the program so that the default colors could
  293.        be modified with some additional command-line parameters (along with
  294.        the menufile name) and then you could have menus with different 
  295.        colors on the screen. 
  296.        
  297.        You could add "boxes" around your options...You could make the whole
  298.        thing into a TSR (but be careful..novices will pop it up in the 
  299.        middle of 1-2-3 and mess things up royally. ) 
  300.        
  301.        You could add a couple of procedures to save and restore the screen
  302.        and use that in place of "clrscr;".
  303.        
  304.        And the ideas just keep coming...MenuEngine will get you started.
  305.        It's up to you to enhance it. Let me know if you make any improvements
  306.        or correct any bugs. 
  307.        --Ed Keefe [CIS 73277,1064]